home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / tcl / tcl67.lha / tcl6.7 / tclUtil.c < prev    next >
C/C++ Source or Header  |  1992-10-21  |  37KB  |  1,459 lines
  1. /* 
  2.  * tclUtil.c --
  3.  *
  4.  *    This file contains utility procedures that are used by many Tcl
  5.  *    commands.
  6.  *
  7.  * Copyright 1987-1991 Regents of the University of California
  8.  * Permission to use, copy, modify, and distribute this
  9.  * software and its documentation for any purpose and without
  10.  * fee is hereby granted, provided that the above copyright
  11.  * notice appear in all copies.  The University of California
  12.  * makes no representations about the suitability of this
  13.  * software for any purpose.  It is provided "as is" without
  14.  * express or implied warranty.
  15.  */
  16.  
  17. #ifndef lint
  18. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUtil.c,v 1.66 92/10/21 16:12:01 ouster Exp $ SPRITE (Berkeley)";
  19. #endif
  20.  
  21. #include "tclInt.h"
  22.  
  23. /*
  24.  * The following values are used in the flags returned by Tcl_ScanElement
  25.  * and used by Tcl_ConvertElement.  The value TCL_DONT_USE_BRACES is also
  26.  * defined in tcl.h;  make sure its value doesn't overlap with any of the
  27.  * values below.
  28.  *
  29.  * TCL_DONT_USE_BRACES -    1 means the string mustn't be enclosed in
  30.  *                braces (e.g. it contains unmatched braces,
  31.  *                or ends in a backslash character, or user
  32.  *                just doesn't want braces);  handle all
  33.  *                special characters by adding backslashes.
  34.  * USE_BRACES -            1 means the string contains a special
  35.  *                character that can be handled simply by
  36.  *                enclosing the entire argument in braces.
  37.  * BRACES_UNMATCHED -        1 means that braces aren't properly matched
  38.  *                in the argument.
  39.  */
  40.  
  41. #define USE_BRACES        2
  42. #define BRACES_UNMATCHED    4
  43.  
  44. /*
  45.  * The variable below is set to NULL before invoking regexp functions
  46.  * and checked after those functions.  If an error occurred then regerror
  47.  * will set the variable to point to a (static) error message.  This
  48.  * mechanism unfortunately does not support multi-threading, but then
  49.  * neither does the rest of the regexp facilities.
  50.  */
  51.  
  52. char *tclRegexpError = NULL;
  53.  
  54. /*
  55.  * Function prototypes for local procedures in this file:
  56.  */
  57.  
  58. static void        SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
  59.                 int newSpace));
  60.  
  61. /*
  62.  *----------------------------------------------------------------------
  63.  *
  64.  * TclFindElement --
  65.  *
  66.  *    Given a pointer into a Tcl list, locate the first (or next)
  67.  *    element in the list.
  68.  *
  69.  * Results:
  70.  *    The return value is normally TCL_OK, which means that the
  71.  *    element was successfully located.  If TCL_ERROR is returned
  72.  *    it means that list didn't have proper list structure;
  73.  *    interp->result contains a more detailed error message.
  74.  *
  75.  *    If TCL_OK is returned, then *elementPtr will be set to point
  76.  *    to the first element of list, and *nextPtr will be set to point
  77.  *    to the character just after any white space following the last
  78.  *    character that's part of the element.  If this is the last argument
  79.  *    in the list, then *nextPtr will point to the NULL character at the
  80.  *    end of list.  If sizePtr is non-NULL, *sizePtr is filled in with
  81.  *    the number of characters in the element.  If the element is in
  82.  *    braces, then *elementPtr will point to the character after the
  83.  *    opening brace and *sizePtr will not include either of the braces.
  84.  *    If there isn't an element in the list, *sizePtr will be zero, and
  85.  *    both *elementPtr and *termPtr will refer to the null character at
  86.  *    the end of list.  Note:  this procedure does NOT collapse backslash
  87.  *    sequences.
  88.  *
  89.  * Side effects:
  90.  *    None.
  91.  *
  92.  *----------------------------------------------------------------------
  93.  */
  94.  
  95. int
  96. TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr)
  97.     Tcl_Interp *interp;        /* Interpreter to use for error reporting. */
  98.     register char *list;    /* String containing Tcl list with zero
  99.                  * or more elements (possibly in braces). */
  100.     char **elementPtr;        /* Fill in with location of first significant
  101.                  * character in first element of list. */
  102.     char **nextPtr;        /* Fill in with location of character just
  103.                  * after all white space following end of
  104.                  * argument (i.e. next argument or end of
  105.                  * list). */
  106.     int *sizePtr;        /* If non-zero, fill in with size of
  107.                  * element. */
  108.     int *bracePtr;        /* If non-zero fill in with non-zero/zero
  109.                  * to indicate that arg was/wasn't
  110.                  * in braces. */
  111. {
  112.     register char *p;
  113.     int openBraces = 0;
  114.     int inQuotes = 0;
  115.     int size;
  116.  
  117.     /*
  118.      * Skim off leading white space and check for an opening brace or
  119.      * quote.   Note:  use of "isascii" below and elsewhere in this
  120.      * procedure is a temporary hack (7/27/90) because Mx uses characters
  121.      * with the high-order bit set for some things.  This should probably
  122.      * be changed back eventually, or all of Tcl should call isascii.
  123.      */
  124.  
  125.     while (isascii(*list) && isspace(*list)) {
  126.     list++;
  127.     }
  128.     if (*list == '{') {
  129.     openBraces = 1;
  130.     list++;
  131.     } else if (*list == '"') {
  132.     inQuotes = 1;
  133.     list++;
  134.     }
  135.     if (bracePtr != 0) {
  136.     *bracePtr = openBraces;
  137.     }
  138.     p = list;
  139.  
  140.     /*
  141.      * Find the end of the element (either a space or a close brace or
  142.      * the end of the string).
  143.      */
  144.  
  145.     while (1) {
  146.     switch (*p) {
  147.  
  148.         /*
  149.          * Open brace: don't treat specially unless the element is
  150.          * in braces.  In this case, keep a nesting count.
  151.          */
  152.  
  153.         case '{':
  154.         if (openBraces != 0) {
  155.             openBraces++;
  156.         }
  157.         break;
  158.  
  159.         /*
  160.          * Close brace: if element is in braces, keep nesting
  161.          * count and quit when the last close brace is seen.
  162.          */
  163.  
  164.         case '}':
  165.         if (openBraces == 1) {
  166.             char *p2;
  167.  
  168.             size = p - list;
  169.             p++;
  170.             if ((isascii(*p) && isspace(*p)) || (*p == 0)) {
  171.             goto done;
  172.             }
  173.             for (p2 = p; (*p2 != 0) && (!isspace(*p2)) && (p2 < p+20);
  174.                 p2++) {
  175.             /* null body */
  176.             }
  177.             Tcl_ResetResult(interp);
  178.             sprintf(interp->result,
  179.                 "list element in braces followed by \"%.*s\" instead of space",
  180.                 p2-p, p);
  181.             return TCL_ERROR;
  182.         } else if (openBraces != 0) {
  183.             openBraces--;
  184.         }
  185.         break;
  186.  
  187.         /*
  188.          * Backslash:  skip over everything up to the end of the
  189.          * backslash sequence.
  190.          */
  191.  
  192.         case '\\': {
  193.         int size;
  194.  
  195.         (void) Tcl_Backslash(p, &size);
  196.         p += size - 1;
  197.         break;
  198.         }
  199.  
  200.         /*
  201.          * Space: ignore if element is in braces or quotes;  otherwise
  202.          * terminate element.
  203.          */
  204.  
  205.         case ' ':
  206.         case '\f':
  207.         case '\n':
  208.         case '\r':
  209.         case '\t':
  210.         case '\v':
  211.         if ((openBraces == 0) && !inQuotes) {
  212.             size = p - list;
  213.             goto done;
  214.         }
  215.         break;
  216.  
  217.         /*
  218.          * Double-quote:  if element is in quotes then terminate it.
  219.          */
  220.  
  221.         case '"':
  222.         if (inQuotes) {
  223.             char *p2;
  224.  
  225.             size = p-list;
  226.             p++;
  227.             if ((isascii(*p) && isspace(*p)) || (*p == 0)) {
  228.             goto done;
  229.             }
  230.             for (p2 = p; (*p2 != 0) && (!isspace(*p2)) && (p2 < p+20);
  231.                 p2++) {
  232.             /* null body */
  233.             }
  234.             Tcl_ResetResult(interp);
  235.             sprintf(interp->result,
  236.                 "list element in quotes followed by \"%.*s\" %s",
  237.                 p2-p, p, "instead of space");
  238.             return TCL_ERROR;
  239.         }
  240.         break;
  241.  
  242.         /*
  243.          * End of list:  terminate element.
  244.          */
  245.  
  246.         case 0:
  247.         if (openBraces != 0) {
  248.             Tcl_SetResult(interp, "unmatched open brace in list",
  249.                 TCL_STATIC);
  250.             return TCL_ERROR;
  251.         } else if (inQuotes) {
  252.             Tcl_SetResult(interp, "unmatched open quote in list",
  253.                 TCL_STATIC);
  254.             return TCL_ERROR;
  255.         }
  256.         size = p - list;
  257.         goto done;
  258.  
  259.     }
  260.     p++;
  261.     }
  262.  
  263.     done:
  264.     while (isascii(*p) && isspace(*p)) {
  265.     p++;
  266.     }
  267.     *elementPtr = list;
  268.     *nextPtr = p;
  269.     if (sizePtr != 0) {
  270.     *sizePtr = size;
  271.     }
  272.     return TCL_OK;
  273. }
  274.  
  275. /*
  276.  *----------------------------------------------------------------------
  277.  *
  278.  * TclCopyAndCollapse --
  279.  *
  280.  *    Copy a string and eliminate any backslashes that aren't in braces.
  281.  *
  282.  * Results:
  283.  *    There is no return value.  Count chars. get copied from src
  284.  *    to dst.  Along the way, if backslash sequences are found outside
  285.  *    braces, the backslashes are eliminated in the copy.
  286.  *    After scanning count chars. from source, a null character is
  287.  *    placed at the end of dst.
  288.  *
  289.  * Side effects:
  290.  *    None.
  291.  *
  292.  *----------------------------------------------------------------------
  293.  */
  294.  
  295. void
  296. TclCopyAndCollapse(count, src, dst)
  297.     int count;            /* Total number of characters to copy
  298.                  * from src. */
  299.     register char *src;        /* Copy from here... */
  300.     register char *dst;        /* ... to here. */
  301. {
  302.     register char c;
  303.     int numRead;
  304.  
  305.     for (c = *src; count > 0; src++, c = *src, count--) {
  306.     if (c == '\\') {
  307.         *dst = Tcl_Backslash(src, &numRead);
  308.         if (*dst != 0) {
  309.         dst++;
  310.         }
  311.         src += numRead-1;
  312.         count -= numRead-1;
  313.     } else {
  314.         *dst = c;
  315.         dst++;
  316.     }
  317.     }
  318.     *dst = 0;
  319. }
  320.  
  321. /*
  322.  *----------------------------------------------------------------------
  323.  *
  324.  * Tcl_SplitList --
  325.  *
  326.  *    Splits a list up into its constituent fields.
  327.  *
  328.  * Results
  329.  *    The return value is normally TCL_OK, which means that
  330.  *    the list was successfully split up.  If TCL_ERROR is
  331.  *    returned, it means that "list" didn't have proper list
  332.  *    structure;  interp->result will contain a more detailed
  333.  *    error message.
  334.  *
  335.  *    *argvPtr will be filled in with the address of an array
  336.  *    whose elements point to the elements of list, in order.
  337.  *    *argcPtr will get filled in with the number of valid elements
  338.  *    in the array.  A single block of memory is dynamically allocated
  339.  *    to hold both the argv array and a copy of the list (with
  340.  *    backslashes and braces removed in the standard way).
  341.  *    The caller must eventually free this memory by calling free()
  342.  *    on *argvPtr.  Note:  *argvPtr and *argcPtr are only modified
  343.  *    if the procedure returns normally.
  344.  *
  345.  * Side effects:
  346.  *    Memory is allocated.
  347.  *
  348.  *----------------------------------------------------------------------
  349.  */
  350.  
  351. int
  352. Tcl_SplitList(interp, list, argcPtr, argvPtr)
  353.     Tcl_Interp *interp;        /* Interpreter to use for error reporting. */
  354.     char *list;            /* Pointer to string with list structure. */
  355.     int *argcPtr;        /* Pointer to location to fill in with
  356.                  * the number of elements in the list. */
  357.     char ***argvPtr;        /* Pointer to place to store pointer to array
  358.                  * of pointers to list elements. */
  359. {
  360.     char **argv;
  361.     register char *p;
  362.     int size, i, result, elSize, brace;
  363.     char *element;
  364.  
  365.     /*
  366.      * Figure out how much space to allocate.  There must be enough
  367.      * space for both the array of pointers and also for a copy of
  368.      * the list.  To estimate the number of pointers needed, count
  369.      * the number of space characters in the list.
  370.      */
  371.  
  372.     for (size = 1, p = list; *p != 0; p++) {
  373.     if (isspace(*p)) {
  374.         size++;
  375.     }
  376.     }
  377.     size++;            /* Leave space for final NULL pointer. */
  378.     argv = (char **) ckalloc((unsigned)
  379.         ((size * sizeof(char *)) + (p - list) + 1));
  380.     for (i = 0, p = ((char *) argv) + size*sizeof(char *);
  381.         *list != 0; i++) {
  382.     result = TclFindElement(interp, list, &element, &list, &elSize, &brace);
  383.     if (result != TCL_OK) {
  384.         ckfree((char *) argv);
  385.         return result;
  386.     }
  387.     if (*element == 0) {
  388.         break;
  389.     }
  390.     if (i >= size) {
  391.         ckfree((char *) argv);
  392.         Tcl_SetResult(interp, "internal error in Tcl_SplitList",
  393.             TCL_STATIC);
  394.         return TCL_ERROR;
  395.     }
  396.     argv[i] = p;
  397.     if (brace) {
  398.         strncpy(p, element, elSize);
  399.         p += elSize;
  400.         *p = 0;
  401.         p++;
  402.     } else {
  403.         TclCopyAndCollapse(elSize, element, p);
  404.         p += elSize+1;
  405.     }
  406.     }
  407.  
  408.     argv[i] = NULL;
  409.     *argvPtr = argv;
  410.     *argcPtr = i;
  411.     return TCL_OK;
  412. }
  413.  
  414. /*
  415.  *----------------------------------------------------------------------
  416.  *
  417.  * Tcl_ScanElement --
  418.  *
  419.  *    This procedure is a companion procedure to Tcl_ConvertElement.
  420.  *    It scans a string to see what needs to be done to it (e.g.
  421.  *    add backslashes or enclosing braces) to make the string into
  422.  *    a valid Tcl list element.
  423.  *
  424.  * Results:
  425.  *    The return value is an overestimate of the number of characters
  426.  *    that will be needed by Tcl_ConvertElement to produce a valid
  427.  *    list element from string.  The word at *flagPtr is filled in
  428.  *    with a value needed by Tcl_ConvertElement when doing the actual
  429.  *    conversion.
  430.  *
  431.  * Side effects:
  432.  *    None.
  433.  *
  434.  *----------------------------------------------------------------------
  435.  */
  436.  
  437. int
  438. Tcl_ScanElement(string, flagPtr)
  439.     char *string;        /* String to convert to Tcl list element. */
  440.     int *flagPtr;        /* Where to store information to guide
  441.                  * Tcl_ConvertElement. */
  442. {
  443.     int flags, nestingLevel;
  444.     register char *p;
  445.  
  446.     /*
  447.      * This procedure and Tcl_ConvertElement together do two things:
  448.      *
  449.      * 1. They produce a proper list, one that will yield back the
  450.      * argument strings when evaluated or when disassembled with
  451.      * Tcl_SplitList.  This is the most important thing.
  452.      * 
  453.      * 2. They try to produce legible output, which means minimizing the
  454.      * use of backslashes (using braces instead).  However, there are
  455.      * some situations where backslashes must be used (e.g. an element
  456.      * like "{abc": the leading brace will have to be backslashed.  For
  457.      * each element, one of three things must be done:
  458.      *
  459.      * (a) Use the element as-is (it doesn't contain anything special
  460.      * characters).  This is the most desirable option.
  461.      *
  462.      * (b) Enclose the element in braces, but leave the contents alone.
  463.      * This happens if the element contains embedded space, or if it
  464.      * contains characters with special interpretation ($, [, ;, or \),
  465.      * or if it starts with a brace or double-quote, or if there are
  466.      * no characters in the element.
  467.      *
  468.      * (c) Don't enclose the element in braces, but add backslashes to
  469.      * prevent special interpretation of special characters.  This is a
  470.      * last resort used when the argument would normally fall under case
  471.      * (b) but contains unmatched braces.  It also occurs if the last
  472.      * character of the argument is a backslash or if the element contains
  473.      * a backslash followed by newline.
  474.      *
  475.      * The procedure figures out how many bytes will be needed to store
  476.      * the result (actually, it overestimates).  It also collects information
  477.      * about the element in the form of a flags word.
  478.      */
  479.  
  480.     nestingLevel = 0;
  481.     flags = 0;
  482.     if (string == NULL) {
  483.     string = "";
  484.     }
  485.     p = string;
  486.     if ((*p == '{') || (*p == '"') || (*p == 0)) {
  487.     flags |= USE_BRACES;
  488.     }
  489.     for ( ; *p != 0; p++) {
  490.     switch (*p) {
  491.         case '{':
  492.         nestingLevel++;
  493.         break;
  494.         case '}':
  495.         nestingLevel--;
  496.         if (nestingLevel < 0) {
  497.             flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED;
  498.         }
  499.         break;
  500.         case '[':
  501.         case '$':
  502.         case ';':
  503.         case ' ':
  504.         case '\f':
  505.         case '\n':
  506.         case '\r':
  507.         case '\t':
  508.         case '\v':
  509.         flags |= USE_BRACES;
  510.         break;
  511.         case '\\':
  512.         if ((p[1] == 0) || (p[1] == '\n')) {
  513.             flags = TCL_DONT_USE_BRACES;
  514.         } else {
  515.             int size;
  516.  
  517.             (void) Tcl_Backslash(p, &size);
  518.             p += size-1;
  519.             flags |= USE_BRACES;
  520.         }
  521.         break;
  522.     }
  523.     }
  524.     if (nestingLevel != 0) {
  525.     flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
  526.     }
  527.     *flagPtr = flags;
  528.  
  529.     /*
  530.      * Allow enough space to backslash every character plus leave
  531.      * two spaces for braces.
  532.      */
  533.  
  534.     return 2*(p-string) + 2;
  535. }
  536.  
  537. /*
  538.  *----------------------------------------------------------------------
  539.  *
  540.  * Tcl_ConvertElement --
  541.  *
  542.  *    This is a companion procedure to Tcl_ScanElement.  Given the
  543.  *    information produced by Tcl_ScanElement, this procedure converts
  544.  *    a string to a list element equal to that string.
  545.  *
  546.  * Results:
  547.  *    Information is copied to *dst in the form of a list element
  548.  *    identical to src (i.e. if Tcl_SplitList is applied to dst it
  549.  *    will produce a string identical to src).  The return value is
  550.  *    a count of the number of characters copied (not including the
  551.  *    terminating NULL character).
  552.  *
  553.  * Side effects:
  554.  *    None.
  555.  *
  556.  *----------------------------------------------------------------------
  557.  */
  558.  
  559. int
  560. Tcl_ConvertElement(src, dst, flags)
  561.     register char *src;        /* Source information for list element. */
  562.     char *dst;            /* Place to put list-ified element. */
  563.     int flags;            /* Flags produced by Tcl_ScanElement. */
  564. {
  565.     register char *p = dst;
  566.  
  567.     /*
  568.      * See the comment block at the beginning of the Tcl_ScanElement
  569.      * code for details of how this works.
  570.      */
  571.  
  572.     if (src == NULL) {
  573.     src = "";
  574.     }
  575.     if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) {
  576.     *p = '{';
  577.     p++;
  578.     for ( ; *src != 0; src++, p++) {
  579.         *p = *src;
  580.     }
  581.     *p = '}';
  582.     p++;
  583.     } else if (*src == 0) {
  584.     /*
  585.      * If string is empty but can't use braces, then use special
  586.      * backslash sequence that maps to empty string.
  587.      */
  588.  
  589.     p[0] = '\\';
  590.     p[1] = '0';
  591.     p += 2;
  592.     } else {
  593.     for (; *src != 0 ; src++) {
  594.         switch (*src) {
  595.         case ']':
  596.         case '[':
  597.         case '$':
  598.         case ';':
  599.         case ' ':
  600.         case '\\':
  601.         case '"':
  602.             *p = '\\';
  603.             p++;
  604.             break;
  605.         case '{':
  606.         case '}':
  607.             if (flags & BRACES_UNMATCHED) {
  608.             *p = '\\';
  609.             p++;
  610.             }
  611.             break;
  612.         case '\f':
  613.             *p = '\\';
  614.             p++;
  615.             *p = 'f';
  616.             p++;
  617.             continue;
  618.         case '\n':
  619.             *p = '\\';
  620.             p++;
  621.             *p = 'n';
  622.             p++;
  623.             continue;
  624.         case '\r':
  625.             *p = '\\';
  626.             p++;
  627.             *p = 'r';
  628.             p++;
  629.             continue;
  630.         case '\t':
  631.             *p = '\\';
  632.             p++;
  633.             *p = 't';
  634.             p++;
  635.             continue;
  636.         case '\v':
  637.             *p = '\\';
  638.             p++;
  639.             *p = 'v';
  640.             p++;
  641.             continue;
  642.         }
  643.         *p = *src;
  644.         p++;
  645.     }
  646.     }
  647.     *p = '\0';
  648.     return p-dst;
  649. }
  650.  
  651. /*
  652.  *----------------------------------------------------------------------
  653.  *
  654.  * Tcl_Merge --
  655.  *
  656.  *    Given a collection of strings, merge them together into a
  657.  *    single string that has proper Tcl list structured (i.e.
  658.  *    Tcl_SplitList may be used to retrieve strings equal to the
  659.  *    original elements, and Tcl_Eval will parse the string back
  660.  *    into its original elements).
  661.  *
  662.  * Results:
  663.  *    The return value is the address of a dynamically-allocated
  664.  *    string containing the merged list.
  665.  *
  666.  * Side effects:
  667.  *    None.
  668.  *
  669.  *----------------------------------------------------------------------
  670.  */
  671.  
  672. char *
  673. Tcl_Merge(argc, argv)
  674.     int argc;            /* How many strings to merge. */
  675.     char **argv;        /* Array of string values. */
  676. {
  677. #   define LOCAL_SIZE 20
  678.     int localFlags[LOCAL_SIZE], *flagPtr;
  679.     int numChars;
  680.     char *result;
  681.     register char *dst;
  682.     int i;
  683.  
  684.     /*
  685.      * Pass 1: estimate space, gather flags.
  686.      */
  687.  
  688.     if (argc <= LOCAL_SIZE) {
  689.     flagPtr = localFlags;
  690.     } else {
  691.     flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int));
  692.     }
  693.     numChars = 1;
  694.     for (i = 0; i < argc; i++) {
  695.     numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1;
  696.     }
  697.  
  698.     /*
  699.      * Pass two: copy into the result area.
  700.      */
  701.  
  702.     result = (char *) ckalloc((unsigned) numChars);
  703.     dst = result;
  704.     for (i = 0; i < argc; i++) {
  705.     numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]);
  706.     dst += numChars;
  707.     *dst = ' ';
  708.     dst++;
  709.     }
  710.     if (dst == result) {
  711.     *dst = 0;
  712.     } else {
  713.     dst[-1] = 0;
  714.     }
  715.  
  716.     if (flagPtr != localFlags) {
  717.     ckfree((char *) flagPtr);
  718.     }
  719.     return result;
  720. }
  721.  
  722. /*
  723.  *----------------------------------------------------------------------
  724.  *
  725.  * Tcl_Concat --
  726.  *
  727.  *    Concatenate a set of strings into a single large string.
  728.  *
  729.  * Results:
  730.  *    The return value is dynamically-allocated string containing
  731.  *    a concatenatBRACES;string dstrings in argv, with spaces between
  732.  *    the original argv elements.
  733.  *
  734.  * Side effects:
  735.  *    Memory is allocated for the result;  the caller is responsible
  736.  *    for freeing the memory.
  737.  *
  738.  *----------------------------------------------------------------------
  739.  */
  740.  
  741. char *
  742. Tcl_Concat(argc, argv)
  743.     int argc;            /* Number of strings to concatenate. */
  744.     char **argv;        /* Array of strings to concatenate. */
  745. {
  746.     int totalSize, i;
  747.     register char *p;
  748.     char *result;
  749.  
  750.     for (totalSize = 1, i = 0; i < argc; i++) {
  751.     totalSize += strlen(argv[i]) + 1;
  752.     }
  753.     result = (char *) ckalloc((unsigned) totalSize);
  754.     if (argc == 0) {
  755.     *result = '\0';
  756.     return result;
  757.     }
  758.     for (p = result, i = 0; i < argc; i++) {
  759.     char *element;
  760.     int length;
  761.  
  762.     /*
  763.      * Clip white space off the front and back of the string
  764.      * to generate a neater result, and ignore any empty
  765.      * elements.
  766.      */
  767.  
  768.     element = argv[i];
  769.     while (isspace(*element)) {
  770.         element++;
  771.     }
  772.     for (length = strlen(element);
  773.         (length > 0) && (isspace(element[length-1]));
  774.         length--) {
  775.         /* Null loop body. */
  776.     }
  777.     if (length == 0) {
  778.         continue;
  779.     }
  780.     (void) strncpy(p, element, length);
  781.     p += length;
  782.     *p = ' ';
  783.     p++;
  784.     }
  785.     if (p != result) {
  786.     p[-1] = 0;
  787.     } else {
  788.     *p = 0;
  789.     }
  790.     return result;
  791. }
  792.  
  793. /*
  794.  *----------------------------------------------------------------------
  795.  *
  796.  * Tcl_StringMatch --
  797.  *
  798.  *    See if a particular string matches a particular pattern.
  799.  *
  800.  * Results:
  801.  *    The return value is 1 if string matches pattern, and
  802.  *    0 otherwise.  The matching operation permits the following
  803.  *    special characters in the pattern: *?\[] (see the manual
  804.  *    entry for details on what these mean).
  805.  *
  806.  * Side effects:
  807.  *    None.
  808.  *
  809.  *----------------------------------------------------------------------
  810.  */
  811.  
  812. int
  813. Tcl_StringMatch(string, pattern)
  814.     register char *string;    /* String. */
  815.     register char *pattern;    /* Pattern, which may contain
  816.                  * special characters. */
  817. {
  818.     char c2;
  819.  
  820.     while (1) {
  821.     /* See if we're at the end of both the pattern and the string.
  822.      * If so, we succeeded.  If we're at the end of the pattern
  823.      * but not at the end of the string, we failed.
  824.      */
  825.     
  826.     if (*pattern == 0) {
  827.         if (*string == 0) {
  828.         return 1;
  829.         } else {
  830.         return 0;
  831.         }
  832.     }
  833.     if ((*string == 0) && (*pattern != '*')) {
  834.         return 0;
  835.     }
  836.  
  837.     /* Check for a "*" as the next pattern character.  It matches
  838.      * any substring.  We handle this by calling ourselves
  839.      * recursively for each postfix of string, until either we
  840.      * match or we reach the end of the string.
  841.      */
  842.     
  843.     if (*pattern == '*') {
  844.         pattern += 1;
  845.         if (*pattern == 0) {
  846.         return 1;
  847.         }
  848.         while (1) {
  849.         if (Tcl_StringMatch(string, pattern)) {
  850.             return 1;
  851.         }
  852.         if (*string == 0) {
  853.             return 0;
  854.         }
  855.         string += 1;
  856.         }
  857.     }
  858.     
  859.     /* Check for a "?" as the next pattern character.  It matches
  860.      * any single character.
  861.      */
  862.  
  863.     if (*pattern == '?') {
  864.         goto thisCharOK;
  865.     }
  866.  
  867.     /* Check for a "[" as the next pattern character.  It is followed
  868.      * by a list of characters that are acceptable, or by a range
  869.      * (two characters separated by "-").
  870.      */
  871.     
  872.     if (*pattern == '[') {
  873.         pattern += 1;
  874.         while (1) {
  875.         if ((*pattern == ']') || (*pattern == 0)) {
  876.             return 0;
  877.         }
  878.         if (*pattern == *string) {
  879.             break;
  880.         }
  881.         if (pattern[1] == '-') {
  882.             c2 = pattern[2];
  883.             if (c2 == 0) {
  884.             return 0;
  885.             }
  886.             if ((*pattern <= *string) && (c2 >= *string)) {
  887.             break;
  888.             }
  889.             if ((*pattern >= *string) && (c2 <= *string)) {
  890.             break;
  891.             }
  892.             pattern += 2;
  893.         }
  894.         pattern += 1;
  895.         }
  896.         while ((*pattern != ']') && (*pattern != 0)) {
  897.         pattern += 1;
  898.         }
  899.         goto thisCharOK;
  900.     }
  901.     
  902.     /* If the next pattern character is '/', just strip off the '/'
  903.      * so we do exact matching on the character that follows.
  904.      */
  905.     
  906.     if (*pattern == '\\') {
  907.         pattern += 1;
  908.         if (*pattern == 0) {
  909.         return 0;
  910.         }
  911.     }
  912.  
  913.     /* There's no special character.  Just make sure that the next
  914.      * characters of each string match.
  915.      */
  916.     
  917.     if (*pattern != *string) {
  918.         return 0;
  919.     }
  920.  
  921.     thisCharOK: pattern += 1;
  922.     string += 1;
  923.     }
  924. }
  925.  
  926. /*
  927.  *----------------------------------------------------------------------
  928.  *
  929.  * Tcl_SetResult --
  930.  *
  931.  *    Arrange for "string" to be the Tcl return value.
  932.  *
  933.  * Results:
  934.  *    None.
  935.  *
  936.  * Side effects:
  937.  *    interp->result is left pointing either to "string" (if "copy" is 0)
  938.  *    or to a copy of string.
  939.  *
  940.  *----------------------------------------------------------------------
  941.  */
  942.  
  943. void
  944. Tcl_SetResult(interp, string, freeProc)
  945.     Tcl_Interp *interp;        /* Interpreter with which to associate the
  946.                  * return value. */
  947.     char *string;        /* Value to be returned.  If NULL,
  948.                  * the result is set to an empty string. */
  949.     Tcl_FreeProc *freeProc;    /* Gives information about the string:
  950.                  * TCL_STATIC, TCL_VOLATILE, or the address
  951.                  * of a Tcl_FreeProc such as free. */
  952. {
  953.     register Interp *iPtr = (Interp *) interp;
  954.     int length;
  955.     Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
  956.     char *oldResult = iPtr->result;
  957.  
  958.     iPtr->freeProc = freeProc;
  959.     if (string == NULL) {
  960.     iPtr->resultSpace[0] = 0;
  961.     iPtr->result = iPtr->resultSpace;
  962.     iPtr->freeProc = 0;
  963.     } else if (freeProc == TCL_VOLATILE) {
  964.     length = strlen(string);
  965.     if (length > TCL_RESULT_SIZE) {
  966.         iPtr->result = (char *) ckalloc((unsigned) length+1);
  967.         iPtr->freeProc = (Tcl_FreeProc *) free;
  968.     } else {
  969.         iPtr->result = iPtr->resultSpace;
  970.         iPtr->freeProc = 0;
  971.     }
  972.     strcpy(iPtr->result, string);
  973.     } else {
  974.     iPtr->result = string;
  975.     }
  976.  
  977.     /*
  978.      * If the old result was dynamically-allocated, free it up.  Do it
  979.      * here, rather than at the beginning, in case the new result value
  980.      * was part of the old result value.
  981.      */
  982.  
  983.     if (oldFreeProc != 0) {
  984.     if (oldFreeProc == (Tcl_FreeProc *) free) {
  985.         ckfree(oldResult);
  986.     } else {
  987.         (*oldFreeProc)(oldResult);
  988.     }
  989.     }
  990. }
  991.  
  992. /*
  993.  *----------------------------------------------------------------------
  994.  *
  995.  * Tcl_AppendResult --
  996.  *
  997.  *    Append a variable number of strings onto the result already
  998.  *    present for an interpreter.
  999.  *
  1000.  * Results:
  1001.  *    None.
  1002.  *
  1003.  * Side effects:
  1004.  *    The result in the interpreter given by the first argument
  1005.  *    is extended by the strings given by the second and following
  1006.  *    arguments (up to a terminating NULL argument).
  1007.  *
  1008.  *----------------------------------------------------------------------
  1009.  */
  1010.  
  1011.     /* VARARGS2 */
  1012. #ifndef lint
  1013. void
  1014. Tcl_AppendResult(va_alist)
  1015. #else
  1016. void
  1017.     /* VARARGS2 */ /* ARGSUSED */
  1018. Tcl_AppendResult(interp, p, va_alist)
  1019.     Tcl_Interp *interp;        /* Interpreter whose result is to be
  1020.                  * extended. */
  1021.     char *p;            /* One or more strings to add to the
  1022.                  * result, terminated with NULL. */
  1023. #endif
  1024.     va_dcl
  1025. {
  1026.     va_list argList;
  1027.     register Interp *iPtr;
  1028.     char *string;
  1029.     int newSpace;
  1030.  
  1031.     /*
  1032.      * First, scan through all the arguments to see how much space is
  1033.      * needed.
  1034.      */
  1035.  
  1036.     va_start(argList);
  1037.     iPtr = va_arg(argList, Interp *);
  1038.     newSpace = 0;
  1039.     while (1) {
  1040.     string = va_arg(argList, char *);
  1041.     if (string == NULL) {
  1042.         break;
  1043.     }
  1044.     newSpace += strlen(string);
  1045.     }
  1046.     va_end(argList);
  1047.  
  1048.     /*
  1049.      * If the append buffer isn't already setup and large enough
  1050.      * to hold the new data, set it up.
  1051.      */
  1052.  
  1053.     if ((iPtr->result != iPtr->appendResult)
  1054.        || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
  1055.        SetupAppendBuffer(iPtr, newSpace);
  1056.     }
  1057.  
  1058.     /*
  1059.      * Final step:  go through all the argument strings again, copying
  1060.      * them into the buffer.
  1061.      */
  1062.  
  1063.     va_start(argList);
  1064.     (void) va_arg(argList, Tcl_Interp *);
  1065.     while (1) {
  1066.     string = va_arg(argList, char *);
  1067.     if (string == NULL) {
  1068.         break;
  1069.     }
  1070.     strcpy(iPtr->appendResult + iPtr->appendUsed, string);
  1071.     iPtr->appendUsed += strlen(string);
  1072.     }
  1073.     va_end(argList);
  1074. }
  1075.  
  1076. /*
  1077.  *----------------------------------------------------------------------
  1078.  *
  1079.  * Tcl_AppendElement --
  1080.  *
  1081.  *    Convert a string to a valid Tcl list element and append it
  1082.  *    to the current result (which is ostensibly a list).
  1083.  *
  1084.  * Results:
  1085.  *    None.
  1086.  *
  1087.  * Side effects:
  1088.  *    The result in the interpreter given by the first argument
  1089.  *    is extended with a list element converted from string.  If
  1090.  *    the original result wasn't empty, then a blank is added before
  1091.  *    the converted list element.
  1092.  *
  1093.  *----------------------------------------------------------------------
  1094.  */
  1095.  
  1096. void
  1097. Tcl_AppendElement(interp, string, noSep)
  1098.     Tcl_Interp *interp;        /* Interpreter whose result is to be
  1099.                  * extended. */
  1100.     char *string;        /* String to convert to list element and
  1101.                  * add to result. */
  1102.     int noSep;            /* If non-zero, then don't output a
  1103.                  * space character before this element,
  1104.                  * even if the element isn't the first
  1105.                  * thing in the output buffer. */
  1106. {
  1107.     register Interp *iPtr = (Interp *) interp;
  1108.     int size, flags;
  1109.     char *dst;
  1110.  
  1111.     /*
  1112.      * See how much space is needed, and grow the append buffer if
  1113.      * needed to accommodate the list element.
  1114.      */
  1115.  
  1116.     size = Tcl_ScanElement(string, &flags) + 1;
  1117.     if ((iPtr->result != iPtr->appendResult)
  1118.        || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
  1119.        SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
  1120.     }
  1121.  
  1122.     /*
  1123.      * Convert the string into a list element and copy it to the
  1124.      * buffer that's forming.
  1125.      */
  1126.  
  1127.     dst = iPtr->appendResult + iPtr->appendUsed;
  1128.     if (!noSep && (iPtr->appendUsed != 0)) {
  1129.     iPtr->appendUsed++;
  1130.     *dst = ' ';
  1131.     dst++;
  1132.     }
  1133.     iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
  1134. }
  1135.  
  1136. /*
  1137.  *----------------------------------------------------------------------
  1138.  *
  1139.  * SetupAppendBuffer --
  1140.  *
  1141.  *    This procedure makes sure that there is an append buffer
  1142.  *    properly initialized for interp, and that it has at least
  1143.  *    enough room to accommodate newSpace new bytes of information.
  1144.  *
  1145.  * Results:
  1146.  *    None.
  1147.  *
  1148.  * Side effects:
  1149.  *    None.
  1150.  *
  1151.  *----------------------------------------------------------------------
  1152.  */
  1153.  
  1154. static void
  1155. SetupAppendBuffer(iPtr, newSpace)
  1156.     register Interp *iPtr;    /* Interpreter whose result is being set up. */
  1157.     int newSpace;        /* Make sure that at least this many bytes
  1158.                  * of new information may be added. */
  1159. {
  1160.     int totalSpace;
  1161.  
  1162.     /*
  1163.      * Make the append buffer larger, if that's necessary, then
  1164.      * copy the current result into the append buffer and make the
  1165.      * append buffer the official Tcl result.
  1166.      */
  1167.  
  1168.     if (iPtr->result != iPtr->appendResult) {
  1169.     /*
  1170.      * If an oversized buffer was used recently, then free it up
  1171.      * so we go back to a smaller buffer.  This avoids tying up
  1172.      * memory forever after a large operation.
  1173.      */
  1174.  
  1175.     if (iPtr->appendAvl > 500) {
  1176.         ckfree(iPtr->appendResult);
  1177.         iPtr->appendResult = NULL;
  1178.         iPtr->appendAvl = 0;
  1179.     }
  1180.     iPtr->appendUsed = strlen(iPtr->result);
  1181.     }
  1182.     totalSpace = newSpace + iPtr->appendUsed;
  1183.     if (totalSpace >= iPtr->appendAvl) {
  1184.     char *new;
  1185.  
  1186.     if (totalSpace < 100) {
  1187.         totalSpace = 200;
  1188.     } else {
  1189.         totalSpace *= 2;
  1190.     }
  1191.     new = (char *) ckalloc((unsigned) totalSpace);
  1192.     strcpy(new, iPtr->result);
  1193.     if (iPtr->appendResult != NULL) {
  1194.         ckfree(iPtr->appendResult);
  1195.     }
  1196.     iPtr->appendResult = new;
  1197.     iPtr->appendAvl = totalSpace;
  1198.     } else if (iPtr->result != iPtr->appendResult) {
  1199.     strcpy(iPtr->appendResult, iPtr->result);
  1200.     }
  1201.     Tcl_FreeResult(iPtr);
  1202.     iPtr->result = iPtr->appendResult;
  1203. }
  1204.  
  1205. /*
  1206.  *----------------------------------------------------------------------
  1207.  *
  1208.  * Tcl_ResetResult --
  1209.  *
  1210.  *    This procedure restores the result area for an interpreter
  1211.  *    to its default initialized state, freeing up any memory that
  1212.  *    may have been allocated for the result and clearing any
  1213.  *    error information for the interpreter.
  1214.  *
  1215.  * Results:
  1216.  *    None.
  1217.  *
  1218.  * Side effects:
  1219.  *    None.
  1220.  *
  1221.  *----------------------------------------------------------------------
  1222.  */
  1223.  
  1224. void
  1225. Tcl_ResetResult(interp)
  1226.     Tcl_Interp *interp;        /* Interpreter for which to clear result. */
  1227. {
  1228.     register Interp *iPtr = (Interp *) interp;
  1229.  
  1230.     Tcl_FreeResult(iPtr);
  1231.     iPtr->result = iPtr->resultSpace;
  1232.     iPtr->resultSpace[0] = 0;
  1233.     iPtr->flags &=
  1234.         ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
  1235. }
  1236.  
  1237. /*
  1238.  *----------------------------------------------------------------------
  1239.  *
  1240.  * Tcl_SetErrorCode --
  1241.  *
  1242.  *    This procedure is called to record machine-readable information
  1243.  *    about an error that is about to be returned.
  1244.  *
  1245.  * Results:
  1246.  *    None.
  1247.  *
  1248.  * Side effects:
  1249.  *    The errorCode global variable is modified to hold all of the
  1250.  *    arguments to this procedure, in a list form with each argument
  1251.  *    becoming one element of the list.  A flag is set internally
  1252.  *    to remember that errorCode has been set, so the variable doesn't
  1253.  *    get set automatically when the error is returned.
  1254.  *
  1255.  *----------------------------------------------------------------------
  1256.  */
  1257.     /* VARARGS2 */
  1258. #ifndef lint
  1259. void
  1260. Tcl_SetErrorCode(va_alist)
  1261. #else
  1262. void
  1263.     /* VARARGS2 */ /* ARGSUSED */
  1264. Tcl_SetErrorCode(interp, p, va_alist)
  1265.     Tcl_Interp *interp;        /* Interpreter whose errorCode variable is
  1266.                  * to be set. */
  1267.     char *p;            /* One or more elements to add to errorCode,
  1268.                  * terminated with NULL. */
  1269. #endif
  1270.     va_dcl
  1271. {
  1272.     va_list argList;
  1273.     char *string;
  1274.     int flags;
  1275.     Interp *iPtr;
  1276.  
  1277.     /*
  1278.      * Scan through the arguments one at a time, appending them to
  1279.      * $errorCode as list elements.
  1280.      */
  1281.  
  1282.     va_start(argList);
  1283.     iPtr = va_arg(argList, Interp *);
  1284.     flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
  1285.     while (1) {
  1286.     string = va_arg(argList, char *);
  1287.     if (string == NULL) {
  1288.         break;
  1289.     }
  1290.     (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
  1291.         (char *) NULL, string, flags);
  1292.     flags |= TCL_APPEND_VALUE;
  1293.     }
  1294.     va_end(argList);
  1295.     iPtr->flags |= ERROR_CODE_SET;
  1296. }
  1297.  
  1298. /*
  1299.  *----------------------------------------------------------------------
  1300.  *
  1301.  * TclGetListIndex --
  1302.  *
  1303.  *    Parse a list index, which may be either an integer or the
  1304.  *    value "end".
  1305.  *
  1306.  * Results:
  1307.  *    The return value is either TCL_OK or TCL_ERROR.  If it is
  1308.  *    TCL_OK, then the index corresponding to string is left in
  1309.  *    *indexPtr.  If the return value is TCL_ERROR, then string
  1310.  *    was bogus;  an error message is returned in interp->result.
  1311.  *    If a negative index is specified, it is rounded up to 0.
  1312.  *    The index value may be larger than the size of the list
  1313.  *    (this happens when "end" is specified).
  1314.  *
  1315.  * Side effects:
  1316.  *    None.
  1317.  *
  1318.  *----------------------------------------------------------------------
  1319.  */
  1320.  
  1321. int
  1322. TclGetListIndex(interp, string, indexPtr)
  1323.     Tcl_Interp *interp;            /* Interpreter for error reporting. */
  1324.     char *string;            /* String containing list index. */
  1325.     int *indexPtr;            /* Where to store index. */
  1326. {
  1327.     if (isdigit(*string) || (*string == '-')) {
  1328.     if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) {
  1329.         return TCL_ERROR;
  1330.     }
  1331.     if (*indexPtr < 0) {
  1332.         *indexPtr = 0;
  1333.     }
  1334.     } else if (strncmp(string, "end", strlen(string)) == 0) {
  1335.     *indexPtr = 1<<30;
  1336.     } else {
  1337.     Tcl_AppendResult(interp, "bad index \"", string,
  1338.         "\": must be integer or \"end\"", (char *) NULL);
  1339.     return TCL_ERROR;
  1340.     }
  1341.     return TCL_OK;
  1342. }
  1343.  
  1344. /*
  1345.  *----------------------------------------------------------------------
  1346.  *
  1347.  * TclCompileRegexp --
  1348.  *
  1349.  *    Compile a regular expression into a form suitable for fast
  1350.  *    matching.  This procedure retains a small cache of pre-compiled
  1351.  *    regular expressions in the interpreter, in order to avoid
  1352.  *    compilation costs as much as possible.
  1353.  *
  1354.  * Results:
  1355.  *    The return value is a pointer to the compiled form of string,
  1356.  *    suitable for passing to regexec.  If an error occurred while
  1357.  *    compiling the pattern, then NULL is returned and an error
  1358.  *    message is left in interp->result.
  1359.  *
  1360.  * Side effects:
  1361.  *    The cache of compiled regexp's in interp will be modified to
  1362.  *    hold information for string, if such information isn't already
  1363.  *    present in the cache.
  1364.  *
  1365.  *----------------------------------------------------------------------
  1366.  */
  1367.  
  1368. regexp *
  1369. TclCompileRegexp(interp, string)
  1370.     Tcl_Interp *interp;            /* For use in error reporting. */
  1371.     char *string;            /* String for which to produce
  1372.                      * compiled regular expression. */
  1373. {
  1374.     register Interp *iPtr = (Interp *) interp;
  1375.     int i, length;
  1376.     regexp *result;
  1377.  
  1378.     length = strlen(string);
  1379.     for (i = 0; i < NUM_REGEXPS; i++) {
  1380.     if ((length == iPtr->patLengths[i])
  1381.         && (strcmp(string, iPtr->patterns[i]) == 0)) {
  1382.         /*
  1383.          * Move the matched pattern to the first slot in the
  1384.          * cache and shift the other patterns down one position.
  1385.          */
  1386.  
  1387.         if (i != 0) {
  1388.         int j;
  1389.         char *cachedString;
  1390.  
  1391.         cachedString = iPtr->patterns[i];
  1392.         result = iPtr->regexps[i];
  1393.         for (j = i-1; j >= 0; j--) {
  1394.             iPtr->patterns[j+1] = iPtr->patterns[j];
  1395.             iPtr->patLengths[j+1] = iPtr->patLengths[j];
  1396.             iPtr->regexps[j+1] = iPtr->regexps[j];
  1397.         }
  1398.         iPtr->patterns[0] = cachedString;
  1399.         iPtr->patLengths[0] = length;
  1400.         iPtr->regexps[0] = result;
  1401.         }
  1402.         return iPtr->regexps[0];
  1403.     }
  1404.     }
  1405.  
  1406.     /*
  1407.      * No match in the cache.  Compile the string and add it to the
  1408.      * cache.
  1409.      */
  1410.  
  1411.     tclRegexpError = NULL;
  1412.     result = regcomp(string);
  1413.     if (tclRegexpError != NULL) {
  1414.     Tcl_AppendResult(interp,
  1415.         "couldn't compile regular expression pattern: ",
  1416.         tclRegexpError, (char *) NULL);
  1417.     return NULL;
  1418.     }
  1419.     if (iPtr->patterns[NUM_REGEXPS-1] != NULL) {
  1420.     ckfree(iPtr->patterns[NUM_REGEXPS-1]);
  1421.     ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]);
  1422.     }
  1423.     for (i = NUM_REGEXPS - 2; i >= 0; i--) {
  1424.     iPtr->patterns[i+1] = iPtr->patterns[i];
  1425.     iPtr->patLengths[i+1] = iPtr->patLengths[i];
  1426.     iPtr->regexps[i+1] = iPtr->regexps[i];
  1427.     }
  1428.     iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
  1429.     strcpy(iPtr->patterns[0], string);
  1430.     iPtr->patLengths[0] = length;
  1431.     iPtr->regexps[0] = result;
  1432.     return result;
  1433. }
  1434.  
  1435. /*
  1436.  *----------------------------------------------------------------------
  1437.  *
  1438.  * regerror --
  1439.  *
  1440.  *    This procedure is invoked by the Henry Spencer's regexp code
  1441.  *    when an error occurs.  It saves the error message so it can
  1442.  *    be seen by the code that called Spencer's code.
  1443.  *
  1444.  * Results:
  1445.  *    None.
  1446.  *
  1447.  * Side effects:
  1448.  *    The value of "string" is saved in "tclRegexpError".
  1449.  *
  1450.  *----------------------------------------------------------------------
  1451.  */
  1452.  
  1453. void
  1454. regerror(string)
  1455.     char *string;            /* Error message. */
  1456. {
  1457.     tclRegexpError = string;
  1458. }
  1459.